home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tcl / utils.tk < prev    next >
Text File  |  1992-07-16  |  16KB  |  569 lines
  1. #
  2. # utils.tk
  3. #    These are convenience procedures that ease construction of
  4. #    buttons, listboxes, etc.  They define all the colors of the
  5. #    widgets based on a set of complementary colors that can
  6. #    be defined externally.  (See also colors.tk.)
  7. #
  8. #    Buttons
  9. #        buttonFrame
  10. #        simpleButton
  11. #        packedButton
  12. #        packedCheckButton
  13. #        packedRadioButton
  14. #    Menu
  15. #        basicMenu
  16. #        packedMenuButton
  17. #    Scrollbar
  18. #        basicScrollbar
  19. #    Listbox
  20. #        labeledListbox
  21. #        unixCommandListbox
  22. #    Entry
  23. #        labeledEntry
  24. #        commandEntry
  25. #        labeledEntryWithDefault
  26. #    Feedback
  27. #        feedbackSetup
  28. #        feedback
  29. #    Toplevel
  30. #        notifier
  31. #    Message
  32. #        unixCommandMessageButton
  33. #        unixCommandMessage
  34. #
  35.  
  36. #
  37. # to_tx - insert characters into the tx command stream.  This is used to
  38. # feed commands to the csh running in the tx that started this program.
  39. #
  40. proc to_tx {str} {
  41.     puts stdout "\33insert \"$str\\n\"\n"
  42. }
  43.  
  44. #
  45. # selfName - determine the name of a nested widget
  46. #    parent is either "." or ".foo.bar"
  47. #    name is ".zork"
  48. #
  49. proc selfName { parent name } {
  50.     if {[string compare $parent "."] == 0} {
  51.     set self $name
  52.     } else {
  53.     set self $parent$name
  54.     }
  55.     return $self
  56. }
  57.  
  58. # Default font for buttons, labels, menus
  59. set buttonFont        fixed
  60. set labelFont        fixed
  61. set menuFont        fixed
  62. set entryFont        fixed
  63.  
  64. #
  65. # Default colors.
  66. # See also colors.tk for a better setColorCube
  67. #
  68. set backgroundColor        #cb02dd
  69. set paleBackground        #ffceff
  70. set foregroundColor        black
  71. set passiveColor        #eeadf3
  72. set activeColor            #f154ff
  73.  
  74. proc setColorCube { foo } { }
  75. proc getColorCube { } { }
  76.  
  77. #
  78. # buttonFrame creates a frame that is designed to hold a row of buttons
  79. #
  80. proc buttonFrame { parent {name .buttons} {border 10} } {
  81.     global backgroundColor
  82.     set self [selfName $parent $name]
  83.     set color [format #%02x%02x%02x 240 128 0]
  84.     frame $self -borderwidth $border -background $backgroundColor
  85.     pack append $parent $self {top fillx}
  86.     return $self
  87. }
  88. #
  89. # packedButton adds a button to a row of buttons
  90. #
  91. proc packedButton { parent name label command {position left} {color default} } {
  92.     global foregroundColor activeColor passiveColor
  93.     global buttonFont
  94.  
  95.     set savedColor [getColorCube]
  96.     if {[string compare $color "default"] != 0} {
  97.     setColorCube $color
  98.     }
  99.     set self [selfName $parent $name]
  100.     button $self -text $label -command $command \
  101.     -font $buttonFont \
  102.     -background $passiveColor \
  103.     -foreground $foregroundColor \
  104.     -activebackground $activeColor \
  105.     -activeforeground $passiveColor
  106.     pack append $parent $self $position
  107.     setColorCube $savedColor
  108.     return $self
  109. }
  110. #
  111. # simpleButton makes some simplifying assumptions - similar to packedButton
  112. #
  113. proc simpleButton { label command {position left} {color default} } {
  114.     global foregroundColor activeColor passiveColor
  115.  
  116.     set savedColor [getColorCube]
  117.     if {[string compare $color "default"] != 0} {
  118.     setColorCube $color
  119.     }
  120.     set self [selfName $parent $name]
  121.     button $self -text $label -command $command \
  122.     -background $passiveColor \
  123.     -foreground $foregroundColor \
  124.     -activebackground $activeColor
  125.     pack append $parent $self $position
  126.     setColorCube $savedColor
  127.     return $self
  128. }
  129. #
  130. # packedCheckButton
  131. #
  132. proc packedCheckButton { parent name label command { variable selectedButton } {position left} } {
  133.     global passiveColor foregroundColor activeColor
  134.  
  135.     set self [selfName $parent $name]
  136.     checkbutton $self -text $label -command $command \
  137.     -variable $variable \
  138.     -background $passiveColor \
  139.     -foreground $foregroundColor \
  140.     -activebackground $activeColor \
  141.     -selector $activeColor
  142.     pack append $parent $self $position
  143.     return $self
  144.  
  145. }
  146.  
  147. #
  148. # packedRadioButton
  149. #
  150. proc packedRadioButton { parent name label command { variable selectedButton } {position left} } {
  151.     global passiveColor foregroundColor activeColor
  152.  
  153.     set self [selfName $parent $name]
  154.     radiobutton $self -text $label -command $command \
  155.     -variable $variable \
  156.     -background $passiveColor \
  157.     -foreground $foregroundColor \
  158.     -activebackground $activeColor \
  159.     -selector $activeColor
  160.     pack append $parent $self $position
  161.     return $self
  162.  
  163. }
  164.  
  165. #
  166. # Basic Menu
  167. #
  168. proc basicMenu { name } {
  169.     global foregroundColor
  170.     global activeColor
  171.     global backgroundColor
  172.     global paleBackground
  173.     global passiveColor
  174.  
  175.     global menuFont
  176.  
  177.     set self [menu $name -font $menuFont \
  178.     -selector $activeColor \
  179.     -background $passiveColor \
  180.     -foreground $foregroundColor \
  181.     -activeforeground $paleBackground \
  182.     -activebackground $activeColor]
  183.  
  184.     return $self
  185. }
  186. #
  187. # packedMenuButton adds a menubutton to a row of buttons
  188. #
  189. proc packedMenuButton { parent name label menu {position left} {color default} } {
  190.     global foregroundColor activeColor passiveColor paleBackground
  191.     global menuFont
  192.  
  193.     set savedColor [getColorCube]
  194.     if {[string compare $color "default"] != 0} {
  195.     setColorCube $color
  196.     }
  197.     set self [selfName $parent $name]
  198.     menubutton $self -text $label -menu $menu \
  199.     -relief raised \
  200.     -font $menuFont \
  201.     -background $passiveColor \
  202.     -foreground $foregroundColor \
  203.     -activebackground $activeColor \
  204.     -activeforeground $paleBackground
  205.     pack append $parent $self $position
  206.     setColorCube $savedColor
  207.     return $self
  208. }
  209. # menuAndButton
  210.  
  211. proc menuAndButton { menubar name label {where {left}} } {
  212.     set menu [basicMenu $menubar${name}Menu]
  213.     packedMenuButton $menubar ${name}Buttton $label $menu $where
  214.     return $menu
  215. }
  216. #
  217. # basicScrollbar
  218. #
  219. proc basicScrollbar { parent command
  220.               {where {left filly frame w}}
  221.               {name .scroll} } {
  222.     global passiveColor activeColor paleBackground backgroundColor
  223.     set self [scrollbar $parent$name -command "$command" \
  224.     -background $backgroundColor \
  225.     -foreground $passiveColor \
  226.     -activeforeground $activeColor]
  227.     pack append $parent $self $where
  228. }
  229. #
  230. # labeledListbox creates a listbox that has a label above it
  231. #
  232. proc labeledListbox { parent name
  233.             {text "Label"} {geometry 10x5} {position left} } {
  234.     global passiveColor activeColor paleBackground
  235.     set self [selfName $parent $name]
  236.     frame   $self  -background $passiveColor
  237.     label   $self.label -text $text -background $passiveColor
  238.     scrollbar $self.scroll -command "$self.list view" \
  239.     -background $paleBackground -foreground $passiveColor \
  240.     -activeforeground $activeColor
  241.     listbox $self.list -geometry $geometry -scroll "$self.scroll set" \
  242.     -background $paleBackground -selectbackground $activeColor
  243.     pack append $parent $self "$position"
  244.     pack append $self $self.label {top} $self.scroll {right filly} $self.list {left expand fill}
  245.     return $self
  246. }
  247. #
  248. # labeledEntry creates an entry that has a label to its left
  249. #
  250. proc labeledEntry { parent name {label "Entry:"} {width 20} {where {left} }} {
  251.     global foregroundColor backgroundColor paleBackground
  252.     global passiveColor activeColor
  253.     global labelFont entryFont
  254.  
  255.     set self [selfName $parent $name]
  256.     # Geometry and Packing
  257.     frame $self -borderwidth 2 -background $backgroundColor -relief raised
  258.     label $self.label -text $label -background $paleBackground -font $labelFont
  259.     entry $self.entry -width $width  -font $entryFont \
  260.         -background $paleBackground \
  261.         -foreground $foregroundColor \
  262.         -selectforeground $passiveColor \
  263.         -selectbackground $activeColor
  264.     pack append $parent $self $where
  265.     pack append $self $self.label {left} \
  266.             $self.entry {right fillx expand}
  267.  
  268.     $self.entry cursor 0
  269.  
  270.     return $self
  271. }
  272.  
  273. # commandEntry --
  274. # An entry widget for entering commands
  275. proc commandEntry { parent { width 20 } { where {bottom fillx expand} } } {
  276.     set self [labeledEntry $parent .command "Command:" $width $where]
  277.     bind $self.entry <Return> "eval \[$self.entry get\]"
  278.     return $self
  279. }
  280.  
  281. #
  282. # Entry with default value remembered in /tmp/file
  283. #
  284. proc defaultGeneric { parent name default } {
  285.     if [file  exists /tmp/$parent/$name] {
  286.     return [exec cat /tmp/$parent/$name]
  287.     } else {
  288.     if {! [file isdirectory /tmp/$parent]} {
  289.         exec mkdir /tmp/$parent
  290.     }
  291.     }
  292.     exec echo $default > /tmp/$parent/$name
  293.     return [exec cat /tmp/$parent/$name]
  294.  
  295. }
  296. proc labeledEntryWithDefault { parent name label width default {where {bottom} } } {
  297.     set widget [labeledEntry $parent $name $label $width $where]
  298.     proc default$name { } "return \[defaultGeneric $parent $name $default\]"
  299.     proc get$name { } "return \[lindex \[$widget.entry get\] 0\]"
  300.     $widget.entry insert 0 [default$name]
  301.     bind $widget.entry <Return> "
  302.     set fileID \[open /tmp/$parent/$name w\]
  303.     puts \$fileID \[get$name\]
  304.     close \$fileID
  305. #    puts stdout \$parent: Remembering $name \[get$name\]\"    
  306.     "
  307. }
  308.  
  309.  
  310. #
  311. # feedback
  312. # Create a frame to hold messages, and define a procedure to display them.
  313. # The feedback procedure will be named
  314. # feedback$parent (e.g., feedback.foo)
  315. #
  316.  
  317. proc feedbackSetup { parent name {width 58} {border 6} } {
  318.     global backgroundColor paleBackground
  319.     global _feedbackWidget
  320.     set self [selfName $parent $name]
  321.  
  322.     frame $self -borderwidth 2 -background $backgroundColor -relief raised
  323.  
  324.     entry $self.entry -width $width -background $paleBackground
  325.     pack append $self $self.entry {left fillx expand}
  326.     pack append $parent $self {left fillx expand}
  327.  
  328.     # Define a per-call procedure to allow for multiple feedback widgets
  329.     proc feedback$parent { text } "
  330.         $self.entry delete 0 end ;
  331.         $self.entry insert 0 \$text ;
  332.         "
  333.  
  334.     # Save the name of the feedback entry for simple clients
  335.     set _feedbackWidget $self.entry
  336.  
  337.     return $self
  338. }
  339. proc feedback { text } {
  340.     global _feedbackWidget
  341.     $_feedbackWidget delete 0 end
  342.     $_feedbackWidget insert 0 $text
  343. }
  344.  
  345. #
  346. # notifier
  347. #
  348. proc notifier {name title text {font fixed} } {
  349.     global paleBackground $name
  350.  
  351.     if {[info exists $name] && [expr {[string compare [set $name] 1] == 0}] } { 
  352.     destroy $name
  353.     set $name 0
  354.     return ""
  355.     } else {
  356.  
  357.     toplevel $name
  358.     set $name 1
  359.  
  360.     wm title $name $title
  361.     
  362.     buttonFrame $name
  363.     
  364.     packedButton $name.buttons .quit "Quit" "destroy $name" left
  365.     
  366.     message $name.msg -aspect 300 -font $font -text $text -background $paleBackground
  367.     pack append $name $name.msg {top expand}
  368.     return $name
  369.     }
  370. }
  371.  
  372. #
  373. # unixCommandMessageButton -
  374. #   A button that runs a UNIX command and puts it output in a message widget
  375. #
  376. proc unixCommandMessageButton { parent name label title args} {
  377.     set self [selfName $parent $name]
  378.     set cmd "unixCommandMessage $name \"$title\" "
  379.     foreach a $args {
  380.     set cmd [concat $cmd $a]
  381.     }
  382.     packedButton $parent $name $label $cmd
  383.     return $self
  384. }
  385. #
  386. # unixCommandMessage -
  387. #  Exec a UNIX command and put the output in a message widget
  388. #
  389. proc unixCommandMessage {name title args} {
  390.     toplevel $name
  391.  
  392.     wm title $name $title
  393.  
  394.     frame $name.buttons -borderwidth 10 -background \
  395.         [format "#%02x%02x%02x" 128 128 200]
  396.     pack append $name $name.buttons {top fillx}
  397.  
  398.     packedButton $name.buttons .quit "Quit" "destroy $name" left
  399.  
  400.     message $name.msg -aspect 300 -font fixed -text [eval exec $args]
  401.     pack append $name $name.msg {top expand}
  402.     return $name
  403. }
  404. #
  405. # unixCommandListbox -
  406. #  Exec a UNIX command and put the output in a labeledListbox
  407. #
  408. proc unixCommandListbox {name title label args} {
  409.     toplevel $name
  410.  
  411.     wm title $name $title
  412.  
  413.     buttonFrame $name
  414.  
  415.     packedButton $name.buttons .quit "Quit" "destroy $name" left
  416.  
  417.     labeledListbox $name .dir $label 20x15 left
  418.     foreach i [eval exec $args] {
  419.     $name.dir.list insert end $i
  420.     }
  421.     return $name
  422. }
  423.  
  424. #####################################################################
  425. # These are additions to the entry widget bindings that rightfully
  426. # belong in tk.tcl, but I don't want folks to have to modify that.
  427. # These add mxedit-like bindings to entry widgets.
  428.  
  429. # The procedure below is invoked to delete the character to the right
  430. # of the cursor in an entry widget.
  431.  
  432. proc tk_entryDelRight w {
  433.     set x [$w index cursor]
  434.     if {$x != -1} {$w delete $x}
  435. }
  436.  
  437. # proc to move the cursor in an entry back one character
  438.  
  439. proc tk_entryBack1char w {
  440.     set x [$w index cursor]
  441.     $w cursor [incr x -1]
  442. }
  443.  
  444. # proc to move the cursor in an entry forward one character
  445.  
  446. proc tk_entryForw1char w {
  447.     set x [$w index cursor]
  448.     $w cursor [incr x +1]
  449. }
  450.  
  451. # proc to move the cursor in an entry to the end of the line
  452.  
  453. proc tk_entryEndOfLine w {
  454.     $w cursor end
  455. }
  456.  
  457. # The procedure below is invoked to backspace over one character
  458. # in an entry widget.  The name of the widget is passed as argument.
  459.  
  460. proc tk_entryBackspace w {
  461.     set x [expr {[$w index cursor] - 1}]
  462.     if {$x != -1} {$w delete $x}
  463. }
  464.  
  465. # The procedure below is invoked to backspace over one word in an
  466. # entry widget.  The name of the widget is passed as argument.
  467.  
  468. proc tk_entryBackword w {
  469.     set string [$w get]
  470.     set curs [expr [$w index cursor]-1]
  471.     if {$curs < 0} return
  472.     for {set x $curs} {$x > 0} {incr x -1} {
  473.     if {([string first [string index $string $x] " \t"] < 0)
  474.         && ([string first [string index $string [expr $x-1]] " \t"]
  475.         >= 0)} {
  476. #        puts stdout "x is $x, string is \"$string\""
  477.         break
  478.     }
  479.     }
  480.     $w delete $x $curs
  481. }
  482.  
  483. #
  484. # Binding stuff from /project/tk/demos/widget
  485. #
  486. #-------------------------------------------------------
  487. # The procedures below provide behavior for widgets like
  488. # entries and menus and menubuttons.  Eventually all of this
  489. # behavior should be built into the widgets, so that this
  490. # code becomes unnecessary.
  491. #-------------------------------------------------------
  492.  
  493. proc bindEntry args {
  494.     foreach w $args {
  495.     bind $w <Any-KeyPress> {%W insert cursor "%A"}
  496.     bind $w <space> {%W insert cursor " "}
  497.     bind $w <ButtonPress-2> {puts stdout "character [%W index @%x]\n"}
  498.     bind $w <Delete> {entryBackspace %W}
  499.     bind $w <BackSpace> {entryBackspace %W}
  500.     bind $w <Control-h> {entryBackspace %W}
  501.     bind $w <Control-l> {entryDelRight %W}
  502.     bind $w <Control-w> {entryBackword %W}
  503.     bind $w <ButtonPress-1> {%W cursor @%x; focus %W; %W select from @%x}
  504.     bind $w <B1-Motion> {%W select to @%x}
  505.     bind $w <Shift-1> {%W select adjust @%x}
  506.     bind $w <Shift-B1-Motion> {%W select to @%x}
  507.     bind $w <ButtonPress-3> {%W scan mark %x}
  508.     bind $w <B3-Motion> {%W scan dragto %x}
  509.     bind $w <Control-d> {%W delete sel.first sel.last}
  510.     bind $w <Control-v> {%W insert cursor [selection get]}
  511.     bind $w <Control-u> {%W delete 0 end}
  512.     }
  513. }
  514.  
  515. proc bindMenu args {
  516.     foreach w $args {
  517.     bind $w <Any-Enter> "$w activate @%y"
  518.     bind $w <Any-Leave> "$w activate none"
  519.     bind $w <Any-Motion> "$w activate @%y"
  520.     bind $w <ButtonRelease-1> "$w invoke active"
  521.     }
  522. }
  523.  
  524. proc bindMenuButton args {
  525.     foreach w $args {
  526.     bind $w <Enter> "$w activate"
  527.     bind $w <B1-Enter> "$w activate; $w config -relief sunken; $w post"
  528.     bind $w <B1-Leave> "$w deactivate; $w config -relief raised"
  529.     bind $w <Shift-B1-Leave> "$w deactivate; $w config -relief raised"
  530.     bind $w <Leave> "$w deactivate"
  531.     bind $w <1> "$w config -relief sunken; $w post"
  532.     bind $w <Shift-1> "$w.m post %X %Y"
  533.     bind $w <ButtonRelease-1> "$w config -relief raised; $w unpost"
  534.     bind $w <Shift-B1-Motion> "$w.m post %X %Y"
  535.     }
  536. }
  537.  
  538. proc entryBackspace win {
  539.     set x [expr {[$win index cursor] - 1}]
  540.     if {$x != -1} {$win delete $x}
  541. }
  542.  
  543. proc entryDelRight win {
  544.     set x [$win index cursor]
  545.     if {$x != -1} {$win delete $x}
  546. }
  547.  
  548. proc entryBackword win {
  549.     set contents [$win get]
  550.     set x [expr {[$win index cursor] - 1}]
  551.     for { } {$x>=0} {set x [expr $x-1]} {
  552.     set c [string index $contents $x]
  553.     if {$c != " "} {
  554.         $win delete $x
  555.     } else {
  556.         $win delete $x
  557.         break
  558.     }
  559.     }
  560. }
  561.  
  562. #
  563. # traceprint
  564. #
  565. proc traceprint { name op oldValue newValue } {
  566.     puts stdout [concat $name " " $op " " $oldValue " " $newValue "\n"]
  567.     return $newValue
  568. }
  569.